Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume24 / gnucalc / part14 < prev next >

Wrap

Text File | 1991-10-29 | 55.5 KB | 1,956 lines

Newsgroups: comp.sources.misc From: daveg@synaptics.com (David Gillespie) Subject: v24i062: gnucalc - GNU Emacs Calculator, v2.00, Part14/56 Message-ID: <1991Oct29.230222.20425@sparky.imd.sterling.com> X-Md4-Signature: 8ab1d10bd41b861c79fc9a0e271f28f2 Date: Tue, 29 Oct 1991 23:02:22 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: daveg@synaptics.com (David Gillespie) Posting-number: Volume 24, Issue 62 Archive-name: gnucalc/part14 Environment: Emacs Supersedes: gmcalc: Volume 13, Issue 27-45 ---- Cut Here and unpack ---- #!/bin/sh # do not concatenate these parts, unpack them in order with /bin/sh # file calc-ext.el continued # if test ! -r _shar_seq_.tmp; then echo 'Please unpack part 1 first!' exit 1 fi (read Scheck if test "$Scheck" != 14; then echo Please unpack part "$Scheck" next! exit 1 else exit 0 fi ) < _shar_seq_.tmp || exit 1 if test ! -f _shar_wnt_.tmp; then echo 'x - still skipping calc-ext.el' else echo 'x - continuing file calc-ext.el' sed 's/^X//' << 'SHAR_EOF' >> 'calc-ext.el' && calc-store-quick calc-store-times calc-subscript calc-unstore) X X ("calc-stuff" calc-clean calc-clean-num calc-flush-caches calc-less-recursion-depth calc-more-recursion-depth calc-num-prefix calc-version calc-why) X X ("calc-trail" calc-trail-backward calc-trail-first calc-trail-forward calc-trail-in calc-trail-isearch-backward calc-trail-isearch-forward calc-trail-kill calc-trail-last calc-trail-marker calc-trail-next calc-trail-out calc-trail-previous calc-trail-scroll-left calc-trail-scroll-right calc-trail-yank) X X ("calc-undo" calc-last-args calc-redo calc-undo) X X ("calc-units" calc-autorange-units calc-base-units calc-convert-temperature calc-convert-units calc-define-unit calc-enter-units-table calc-explain-units calc-extract-units calc-get-unit-definition calc-permanent-units calc-remove-units calc-simplify-units calc-undefine-unit calc-view-units-table) X X ("calc-vec" calc-arrange-vector calc-build-vector calc-cnorm calc-conj-transpose calc-cons calc-cross calc-diag calc-display-strings calc-expand-vector calc-grade calc-head calc-histogram calc-ident calc-index calc-mask-vector calc-mcol calc-mrow calc-pack calc-pack-bits calc-remove-duplicates calc-reverse-vector calc-rnorm calc-set-cardinality calc-set-complement calc-set-difference calc-set-enumerate calc-set-floor calc-set-intersect calc-set-span calc-set-union calc-set-xor calc-sort calc-subvector calc-tail calc-transpose calc-unpack calc-unpack-bits calc-vector-find calc-vlength) X X ("calc-yank" calc-copy-as-kill calc-copy-region-as-kill calc-copy-to-buffer calc-edit calc-edit-cancel calc-edit-mode calc-kill calc-kill-region calc-yank) X )) X ) X (defun calc-init-prefixes () X (if calc-shift-prefix X (progn X (aset calc-mode-map ?A (aref calc-mode-map ?a)) X (aset calc-mode-map ?B (aref calc-mode-map ?b)) X (aset calc-mode-map ?C (aref calc-mode-map ?c)) X (aset calc-mode-map ?D (aref calc-mode-map ?d)) X (aset calc-mode-map ?F (aref calc-mode-map ?f)) X (aset calc-mode-map ?G (aref calc-mode-map ?g)) X (aset calc-mode-map ?J (aref calc-mode-map ?j)) X (aset calc-mode-map ?K (aref calc-mode-map ?k)) X (aset calc-mode-map ?M (aref calc-mode-map ?m)) X (aset calc-mode-map ?S (aref calc-mode-map ?s)) X (aset calc-mode-map ?T (aref calc-mode-map ?t)) X (aset calc-mode-map ?U (aref calc-mode-map ?u))) X (define-key calc-mode-map "A" 'calc-abs) X (define-key calc-mode-map "B" 'calc-log) X (define-key calc-mode-map "C" 'calc-cos) X (define-key calc-mode-map "D" 'calc-redo) X (define-key calc-mode-map "F" 'calc-floor) X (define-key calc-mode-map "G" 'calc-argument) X (define-key calc-mode-map "J" 'calc-conj) X (define-key calc-mode-map "K" 'calc-keep-args) X (define-key calc-mode-map "M" 'calc-more-recursion-depth) X (define-key calc-mode-map "S" 'calc-sin) X (define-key calc-mode-map "T" 'calc-tan) X (define-key calc-mode-map "U" 'calc-undo)) ) X (calc-init-extensions) X X X X ;;;; Miscellaneous. X (defun calc-clear-command-flag (f) X (setq calc-command-flags (delq f calc-command-flags)) ) X X (defun calc-record-message (tag &rest args) X (let ((msg (apply 'format args))) X (message "%s" msg) X (calc-record msg tag)) X (calc-clear-command-flag 'clear-message) ) X X (defun calc-normalize-fancy (val) X (let ((simp (if (consp calc-simplify-mode) X (car calc-simplify-mode) X calc-simplify-mode))) X (cond ((eq simp 'binary) X (let ((s (math-normalize val))) X (if (math-realp s) X (math-clip (math-round s)) X s))) X ((eq simp 'alg) X (math-simplify val)) X ((eq simp 'ext) X (math-simplify-extended val)) X ((eq simp 'units) X (math-simplify-units val)) X (t ; nil, none, num X (math-normalize val)))) ) X X X (if (boundp 'calc-help-map) X nil X (setq calc-help-map (make-keymap)) X (define-key calc-help-map "b" 'calc-describe-bindings) X (define-key calc-help-map "c" 'calc-describe-key-briefly) X (define-key calc-help-map "f" 'calc-describe-function) X (define-key calc-help-map "h" 'calc-full-help) X (define-key calc-help-map "i" 'calc-info) X (define-key calc-help-map "k" 'calc-describe-key) X (define-key calc-help-map "n" 'calc-view-news) X (define-key calc-help-map "s" 'calc-info-summary) X (define-key calc-help-map "t" 'calc-tutorial) X (define-key calc-help-map "v" 'calc-describe-variable) X (define-key calc-help-map "\C-c" 'calc-describe-copying) X (define-key calc-help-map "\C-d" 'calc-describe-distribution) X (define-key calc-help-map "\C-n" 'calc-view-news) X (define-key calc-help-map "\C-w" 'calc-describe-no-warranty) X (define-key calc-help-map "?" 'calc-help-for-help) X (define-key calc-help-map "\C-h" 'calc-help-for-help) ) X X (defun calc-do-prefix-help (msgs group key) X (if calc-full-help-flag X (list msgs group key) X (if (cdr msgs) X (progn X (setq calc-prefix-help-phase X (if (eq this-command last-command) X (% (1+ calc-prefix-help-phase) (1+ (length msgs))) X 0)) X (let ((msg (nth calc-prefix-help-phase msgs))) X (message "%s" (if msg X (concat group ": " msg ":" X (make-string X (- (apply 'max (mapcar 'length msgs)) X (length msg)) 32) X " [MORE]" X (if key X (concat " " (char-to-string key) X "-") X "")) X (if key (format "%c-" key) ""))))) X (setq calc-prefix-help-phase 0) X (if key X (if msgs X (message (concat group ": " (car msgs) ": " X (char-to-string key) "-")) X (message (concat group ": (none) " (char-to-string key) "-"))) X (message (concat group ": " (car msgs))))) X (and key X (setq unread-command-char key))) ) (defvar calc-prefix-help-phase 0) X X X X ;;;; Commands. X X ;;; General. X (defun calc-reset (arg) X (interactive "P") X (save-excursion X (or (eq major-mode 'calc-mode) X (calc-create-buffer)) X (if calc-embedded-info X (calc-embedded nil)) X (or arg X (setq calc-stack nil)) X (setq calc-undo-list nil X calc-redo-list nil) X (let (calc-stack) X (mapcar (function (lambda (v) (set v nil))) calc-local-var-list)) X (mapcar (function (lambda (v) (set (car v) (nth 1 v)))) calc-mode-var-list) X (calc-set-language nil nil t) X (calc-mode) X (let ((executing-kbd-macro "")) ; inhibit message X (calc-flush-caches)) X (run-hooks 'calc-reset-hook)) X (calc-wrapper X (let ((win (get-buffer-window (current-buffer)))) X (calc-realign 0) X (if win X (let ((height (- (window-height win) 2))) X (set-window-point win (point)) X (or (= height calc-window-height) X (let ((swin (selected-window))) X (select-window win) X (enlarge-window (- calc-window-height height)) X (select-window swin))))))) X (message "(Calculator reset)") ) X X (defun calc-scroll-left (n) X (interactive "P") X (scroll-left (or n (/ (window-width) 2))) ) X (defun calc-scroll-right (n) X (interactive "P") X (scroll-right (or n (/ (window-width) 2))) ) X (defun calc-scroll-up (n) X (interactive "P") X (condition-case err X (scroll-up (or n (/ (window-height) 2))) X (error nil)) X (if (pos-visible-in-window-p (max 1 (- (point-max) 2))) X (if (eq major-mode 'calc-mode) X (calc-realign) X (goto-char (point-max)) X (set-window-start (selected-window) X (save-excursion X (forward-line (- (1- (window-height)))) X (point))) X (forward-line -1))) ) X (defun calc-scroll-down (n) X (interactive "P") X (or (pos-visible-in-window-p 1) X (scroll-down (or n (/ (window-height) 2)))) ) X X (defun calc-precision (n) X (interactive "NPrecision: ") X (calc-wrapper X (if (< (prefix-numeric-value n) 3) X (error "Precision must be at least 3 digits.") X (calc-change-mode 'calc-internal-prec (prefix-numeric-value n) X (and (memq (car calc-float-format) '(float sci eng)) X (< (nth 1 calc-float-format) X (if (= calc-number-radix 10) 0 1)))) X (calc-record calc-internal-prec "prec")) X (message "Floating-point precision is %d digits." calc-internal-prec)) ) X X (defun calc-inverse (&optional n) X (interactive "P") X (calc-fancy-prefix 'calc-inverse-flag "Inverse..." n) ) X (defun calc-fancy-prefix (flag msg arg) X (let (prefix) X (calc-wrapper X (calc-set-command-flag 'keep-flags) X (calc-set-command-flag 'no-align) X (setq prefix (set flag (not (symbol-value flag))) X prefix-arg n) X (message (if prefix msg ""))) X (and prefix X (not calc-is-keypad-press) X (if (eq (setq last-command-char (read-char)) ?\C-u) X (universal-argument) X (if (and (< last-command-char ? ) X (not (memq last-command-char '(?\e)))) X (calc-wrapper)) ; clear flags if not a Calc command. X (if (eq last-command-char ?-) X (setq unread-command-char last-command-char) X (digit-argument n))))) ) (setq calc-is-keypad-press nil) X (defun calc-invert-func () X (save-excursion X (calc-select-buffer) X (setq calc-inverse-flag (not (calc-is-inverse)) X calc-hyperbolic-flag (calc-is-hyperbolic) X current-prefix-arg nil)) ) X (defun calc-is-inverse () X calc-inverse-flag ) X (defun calc-hyperbolic (&optional n) X (interactive "P") X (calc-fancy-prefix 'calc-hyperbolic-flag "Hyperbolic..." n) ) X (defun calc-hyperbolic-func () X (save-excursion X (calc-select-buffer) X (setq calc-inverse-flag (calc-is-inverse) X calc-hyperbolic-flag (not (calc-is-hyperbolic)) X current-prefix-arg nil)) ) X (defun calc-is-hyperbolic () X calc-hyperbolic-flag ) X (defun calc-keep-args (&optional n) X (interactive "P") X (calc-fancy-prefix 'calc-keep-args-flag "Keep args..." n) ) X X (defun calc-change-mode (var value &optional refresh option) X (if option X (setq value (if value X (> (prefix-numeric-value value) 0) X (not (symbol-value var))))) X (or (consp var) (setq var (list var) value (list value))) X (if calc-inverse-flag X (let ((old nil)) X (or refresh (error "Not a display-mode command")) X (calc-check-stack 1) X (unwind-protect X (let ((v var)) X (while v X (setq old (cons (symbol-value (car v)) old)) X (set (car v) (car value)) X (setq v (cdr v) X value (cdr value))) X (calc-refresh-top 1) X (calc-refresh-evaltos) X (symbol-value (car var))) X (let ((v var)) X (setq old (nreverse old)) X (while v X (set (car v) (car old)) X (setq v (cdr v) X old (cdr old))) X (if (eq (car var) 'calc-language) X (calc-set-language calc-language calc-language-option t))))) X (let ((chg nil) X (v var)) X (while v X (or (equal (symbol-value (car v)) (car value)) X (progn X (set (car v) (car value)) X (if (eq (car v) 'calc-float-format) X (setq calc-full-float-format X (list (if (eq (car (car value)) 'fix) X 'float X (car (car value))) X 0))) X (setq chg t))) X (setq v (cdr v) X value (cdr value))) X (if chg X (progn X (or (and refresh (calc-do-refresh)) X (calc-refresh-evaltos)) X (and (eq calc-mode-save-mode 'save) X (not (equal var '(calc-mode-save-mode))) X (calc-save-modes t)))) X (if calc-embedded-info (calc-embedded-modes-change var)) X (symbol-value (car var)))) ) X (defun calc-refresh-top (n) X (interactive "p") X (calc-wrapper X (cond ((< n 0) X (setq n (- n)) X (let ((entry (calc-top n 'entry)) X (calc-undo-list nil) (calc-redo-list nil)) X (calc-pop-stack 1 n t) X (calc-push-list (list (car entry)) n (list (nth 2 entry))))) X ((= n 0) X (calc-refresh)) X (t X (let ((entries (calc-top-list n 1 'entry)) X (calc-undo-list nil) (calc-redo-list nil)) X (calc-pop-stack n 1 t) X (calc-push-list (mapcar 'car entries) X 1 X (mapcar (function (lambda (x) (nth 2 x))) X entries)))))) ) X (defun calc-refresh-evaltos (&optional which-var) X (and calc-any-evaltos calc-auto-recompute (not calc-no-refresh-evaltos) X (let ((calc-refreshing-evaltos t) X (num (calc-stack-size)) X (calc-undo-list nil) (calc-redo-list nil) X value new-val) X (while (> num 0) X (setq value (calc-top num 'entry)) X (if (and (not (nth 2 value)) X (setq value (car value)) X (or (eq (car-safe value) 'calcFunc-evalto) X (and (eq (car-safe value) 'vec) X (eq (car-safe (nth 1 value)) 'calcFunc-evalto)))) X (progn X (setq new-val (math-normalize value)) X (or (equal new-val value) X (progn X (calc-push-list (list new-val) num) X (calc-pop-stack 1 (1+ num) t))))) X (setq num (1- num))))) X (and calc-embedded-active which-var X (calc-embedded-var-change which-var)) ) (setq calc-refreshing-evaltos nil) (setq calc-no-refresh-evaltos nil) X X (defun calc-push (&rest vals) X (calc-push-list vals) ) X (defun calc-pop-push (n &rest vals) X (calc-pop-push-list n vals) ) X (defun calc-pop-push-record (n prefix &rest vals) X (calc-pop-push-record-list n prefix vals) ) X X (defun calc-evaluate (n) X (interactive "p") X (calc-slow-wrapper X (if (= n 0) X (setq n (calc-stack-size))) X (calc-with-default-simplification X (if (< n 0) X (calc-pop-push-record-list 1 "eval" X (math-evaluate-expr (calc-top (- n))) X (- n)) X (calc-pop-push-record-list n "eval" (mapcar 'math-evaluate-expr X (calc-top-list n))))) X (calc-handle-whys)) ) X X (defun calc-eval-num (n) X (interactive "P") X (calc-slow-wrapper X (let* ((nn (prefix-numeric-value n)) X (calc-internal-prec (cond ((>= nn 3) nn) X ((< nn 0) (max (+ calc-internal-prec nn) X 3)) X (t calc-internal-prec))) X (calc-symbolic-mode nil)) X (calc-with-default-simplification X (calc-pop-push-record 1 "num" (math-evaluate-expr (calc-top 1))))) X (calc-handle-whys)) ) X X (defun calc-execute-extended-command (n) X (interactive "P") X (let* ((prompt (concat (calc-num-prefix-name n) "M-x ")) X (cmd (intern (completing-read prompt obarray 'commandp t "calc-")))) X (setq prefix-arg n) X (command-execute cmd)) ) X X (defun calc-realign (&optional num) X (interactive "P") X (if (and num (eq major-mode 'calc-mode)) X (progn X (calc-check-stack num) X (calc-cursor-stack-index num) X (and calc-line-numbering X (forward-char 4))) X (if (and calc-embedded-info X (eq (current-buffer) (aref calc-embedded-info 0))) X (progn X (goto-char (aref calc-embedded-info 2)) X (if (save-excursion (set-buffer (aref calc-embedded-info 1)) X calc-show-plain) X (forward-line 1))) X (calc-wrapper X (if (get-buffer-window (current-buffer)) X (set-window-hscroll (get-buffer-window (current-buffer)) 0))))) ) X X X (setq math-cache-list nil) X X X X (defun calc-var-value (v) X (and (symbolp v) X (boundp v) X (symbol-value v) X (if (symbolp (symbol-value v)) X (set v (funcall (symbol-value v))) X (if (stringp (symbol-value v)) X (let ((val (math-read-expr (symbol-value v)))) X (if (eq (car-safe val) 'error) X (error "Bad format in variable contents: %s" (nth 2 val)) X (set v val))) X (symbol-value v)))) ) X X X X X ;;; In the following table, ( OP LOPS ROPS ) means that if an OP ;;; term appears as the first argument to any LOPS term, or as the ;;; second argument to any ROPS term, then they should be treated ;;; as one large term for purposes of associative selection. (defconst calc-assoc-ops '( ( + ( + - ) ( + ) ) X ( - ( + - ) ( + ) ) X ( * ( * ) ( * ) ) X ( / ( / ) ( ) ) X ( | ( | ) ( | ) ) X ( calcFunc-land ( calcFunc-land ) X ( calcFunc-land ) ) X ( calcFunc-lor ( calcFunc-lor ) X ( calcFunc-lor ) ) )) X X (defvar var-CommuteRules 'calc-CommuteRules) (defvar var-JumpRules 'calc-JumpRules) (defvar var-DistribRules 'calc-DistribRules) (defvar var-MergeRules 'calc-MergeRules) (defvar var-NegateRules 'calc-NegateRules) (defvar var-InvertRules 'calc-InvertRules) X X (defconst calc-tweak-eqn-table '( ( calcFunc-eq calcFunc-eq calcFunc-neq ) X ( calcFunc-neq calcFunc-neq calcFunc-eq ) X ( calcFunc-lt calcFunc-gt calcFunc-geq ) X ( calcFunc-gt calcFunc-lt calcFunc-leq ) X ( calcFunc-leq calcFunc-geq calcFunc-gt ) X ( calcFunc-geq calcFunc-leq calcFunc-lt ) )) X X X X (defun calc-float (arg) X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "flt" X (if (calc-is-hyperbolic) 'calcFunc-float 'calcFunc-pfloat) X arg)) ) X X (defvar calc-gnuplot-process nil) X X (defun calc-gnuplot-alive () X (and calc-gnuplot-process X calc-gnuplot-buffer X (buffer-name calc-gnuplot-buffer) X calc-gnuplot-input X (buffer-name calc-gnuplot-input) X (memq (process-status calc-gnuplot-process) '(run stop))) ) X X X X X (defun calc-load-everything () X (interactive) X (calc-need-macros) ; calc-macs.el X (calc-record-list nil) ; calc-misc.el X (math-read-exprs "0") ; calc-aent.el X ;;;; (Loads here) X (calc-Need-calc-alg-2) X (calc-Need-calc-alg-3) X (calc-Need-calc-alg) X (calc-Need-calc-arith) X (calc-Need-calc-bin) X (calc-Need-calc-comb) X (calc-Need-calc-comp) X (calc-Need-calc-cplx) X (calc-Need-calc-embed) X (calc-Need-calc-fin) X (calc-Need-calc-forms) X (calc-Need-calc-frac) X (calc-Need-calc-funcs) X (calc-Need-calc-graph) X (calc-Need-calc-help) X (calc-Need-calc-incom) X (calc-Need-calc-keypd) X (calc-Need-calc-lang) X (calc-Need-calc-map) X (calc-Need-calc-mat) X (calc-Need-calc-math) X (calc-Need-calc-mode) X (calc-Need-calc-poly) X (calc-Need-calc-prog) X (calc-Need-calc-rewr) X (calc-Need-calc-rules) X (calc-Need-calc-sel-2) X (calc-Need-calc-sel) X (calc-Need-calc-stat) X (calc-Need-calc-store) X (calc-Need-calc-stuff) X (calc-Need-calc-trail) X (calc-Need-calc-undo) X (calc-Need-calc-units) X (calc-Need-calc-vec) X (calc-Need-calc-yank) X X (message "All parts of Calc are now loaded.") ) X X ;;; Vector commands. X (defun calc-concat (arg) X (interactive "P") X (calc-wrapper X (if (calc-is-inverse) X (if (calc-is-hyperbolic) X (calc-enter-result 2 "apnd" (list 'calcFunc-append X (calc-top 1) (calc-top 2))) X (calc-enter-result 2 "|" (list 'calcFunc-vconcat X (calc-top 1) (calc-top 2)))) X (if (calc-is-hyperbolic) X (calc-binary-op "apnd" 'calcFunc-append arg '(vec)) X (calc-binary-op "|" 'calcFunc-vconcat arg '(vec) nil '|)))) ) X (defun calc-append (arg) X (interactive "P") X (calc-hyperbolic-func) X (calc-concat arg) ) X X (defconst calc-arg-values '( ( var ArgA var-ArgA ) ( var ArgB var-ArgB ) X ( var ArgC var-ArgC ) ( var ArgD var-ArgD ) X ( var ArgE var-ArgE ) ( var ArgF var-ArgF ) X ( var ArgG var-ArgG ) ( var ArgH var-ArgH ) X ( var ArgI var-ArgI ) ( var ArgJ var-ArgJ ) )) X (defun calc-invent-args (n) X (nreverse (nthcdr (- (length calc-arg-values) n) (reverse calc-arg-values))) ) X X X X ;;; User menu. X (defun calc-user-key-map () X (let ((res (cdr (elt calc-mode-map ?z)))) X (if (eq (car (car res)) 27) X (cdr res) X res)) ) X (defun calc-z-prefix-help () X (interactive) X (let* ((msgs nil) X (buf "") X (kmap (sort (copy-sequence (calc-user-key-map)) X (function (lambda (x y) (< (car x) (car y)))))) X (flags (apply 'logior X (mapcar (function X (lambda (k) X (calc-user-function-classify (car k)))) X kmap)))) X (if (= (logand flags 8) 0) X (calc-user-function-list kmap 7) X (calc-user-function-list kmap 1) X (setq msgs (cons buf msgs) X buf "") X (calc-user-function-list kmap 6)) X (if (/= flags 0) X (setq msgs (cons buf msgs))) X (calc-do-prefix-help (nreverse msgs) "user" ?z)) ) X (defun calc-user-function-classify (key) X (cond ((/= key (downcase key)) ; upper-case X (if (assq (downcase key) (calc-user-key-map)) 9 1)) X ((/= key (upcase key)) 2) ; lower-case X ((= key ??) 0) X (t 4)) ; other ) X (defun calc-user-function-list (map flags) X (and map X (let* ((key (car (car map))) X (kind (calc-user-function-classify key)) X (func (cdr (car map)))) X (if (or (= (logand kind flags) 0) X (not (symbolp func))) X () X (let* ((name (symbol-name func)) X (name (if (string-match "\\`calc-" name) X (substring name 5) name)) X (pos (string-match (char-to-string key) name)) X (desc X (if (symbolp func) X (if (= (logand kind 3) 0) X (format "`%c' = %s" key name) X (if pos X (format "%s%c%s" X (downcase (substring name 0 pos)) X (upcase key) X (downcase (substring name (1+ pos)))) X (format "%c = %s" X (upcase key) X (downcase name)))) X (char-to-string (upcase key))))) X (if (= (length buf) 0) X (setq buf (concat (if (= flags 1) "SHIFT + " "") X desc)) X (if (> (+ (length buf) (length desc)) 58) X (setq msgs (cons buf msgs) X buf (concat (if (= flags 1) "SHIFT + " "") X desc)) X (setq buf (concat buf ", " desc)))))) X (calc-user-function-list (cdr map) flags))) ) X X X (defun calc-shift-Z-prefix-help () X (interactive) X (calc-do-prefix-help X '("Define, Undefine, Formula, Kbd-macro, Edit, Get-defn" X "Composition; Invocation; Permanent; Timing" X "kbd-macros: [ (if), : (else), | (else-if), ] (end-if)" X "kbd-macros: < > (repeat), ( ) (for), { } (loop)" X "kbd-macros: / (break)" X "kbd-macros: ` (save), ' (restore)") X "user" ?Z) ) X X ;;;; Caches. X (defmacro math-defcache (name init form) X (let ((cache-prec (intern (concat (symbol-name name) "-cache-prec"))) X (cache-val (intern (concat (symbol-name name) "-cache"))) X (last-prec (intern (concat (symbol-name name) "-last-prec"))) X (last-val (intern (concat (symbol-name name) "-last")))) X (list 'progn X (list 'setq cache-prec (if init (math-numdigs (nth 1 init)) -100)) X (list 'setq cache-val (list 'quote init)) X (list 'setq last-prec -100) X (list 'setq last-val nil) X (list 'setq 'math-cache-list X (list 'cons X (list 'quote cache-prec) X (list 'cons X (list 'quote last-prec) X 'math-cache-list))) X (list 'defun X name () X (list 'or X (list '= last-prec 'calc-internal-prec) X (list 'setq X last-val X (list 'math-normalize X (list 'progn X (list 'or X (list '>= cache-prec X 'calc-internal-prec) X (list 'setq X cache-val X (list 'let X '((calc-internal-prec X (+ calc-internal-prec X 4))) X form) X cache-prec X '(+ calc-internal-prec 2))) X cache-val)) X last-prec 'calc-internal-prec)) X last-val))) ) (put 'math-defcache 'lisp-indent-hook 2) X ;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public] (math-defcache math-pi (float (bigpos 463 238 793 589 653 592 141 3) -21) X (math-add-float (math-mul-float '(float 16 0) X (math-arctan-raw '(float 2 -1))) X (math-mul-float '(float -4 0) X (math-arctan-raw X (math-float '(frac 1 239)))))) X (math-defcache math-two-pi nil X (math-mul-float (math-pi) '(float 2 0))) X (math-defcache math-pi-over-2 nil X (math-mul-float (math-pi) '(float 5 -1))) X (math-defcache math-pi-over-4 nil X (math-mul-float (math-pi) '(float 25 -2))) X (math-defcache math-pi-over-180 nil X (math-div-float (math-pi) '(float 18 1))) X (math-defcache math-sqrt-pi nil X (math-sqrt-float (math-pi))) X (math-defcache math-sqrt-2 nil X (math-sqrt-float '(float 2 0))) X (math-defcache math-sqrt-12 nil X (math-sqrt-float '(float 12 0))) X (math-defcache math-sqrt-two-pi nil X (math-sqrt-float (math-two-pi))) X (math-defcache math-sqrt-e (float (bigpos 849 146 128 700 270 721 648 1) -21) X (math-add-float '(float 1 0) (math-exp-minus-1-raw '(float 5 -1)))) X (math-defcache math-e nil X (math-pow (math-sqrt-e) 2)) X (math-defcache math-phi nil X (math-mul-float (math-add-float (math-sqrt-raw '(float 5 0)) '(float 1 0)) X '(float 5 -1))) X (math-defcache math-gamma-const nil X '(float (bigpos 495 467 917 632 470 369 709 646 776 267 677 848 348 672 X 057 988 235 399 359 593 421 310 024 824 900 120 065 606 X 328 015 649 156 772 5) -100)) X (defun math-half-circle (symb) X (if (eq calc-angle-mode 'rad) X (if symb X '(var pi var-pi) X (math-pi)) X 180) ) X (defun math-full-circle (symb) X (math-mul 2 (math-half-circle symb)) ) X (defun math-quarter-circle (symb) X (math-div (math-half-circle symb) 2) ) X X X X ;;;; Miscellaneous math routines. X ;;; True if A is an odd integer. [P R R] [Public] (defun math-oddp (a) X (if (consp a) X (and (memq (car a) '(bigpos bigneg)) X (= (% (nth 1 a) 2) 1)) X (/= (% a 2) 0)) ) X ;;; True if A is a small or big integer. [P x] [Public] (defun math-integerp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg))) ) X ;;; True if A is (numerically) a non-negative integer. [P N] [Public] (defun math-natnump (a) X (or (natnump a) X (eq (car-safe a) 'bigpos)) ) X ;;; True if A is a rational (or integer). [P x] [Public] (defun math-ratp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac))) ) X ;;; True if A is a real (or rational). [P x] [Public] (defun math-realp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float))) ) X ;;; True if A is a real or HMS form. [P x] [Public] (defun math-anglep (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float hms))) ) X ;;; True if A is a number of any kind. [P x] [Public] (defun math-numberp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float cplx polar))) ) X ;;; True if A is a complex number or angle. [P x] [Public] (defun math-scalarp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float cplx polar hms))) ) X ;;; True if A is a vector. [P x] [Public] (defun math-vectorp (a) X (eq (car-safe a) 'vec) ) X ;;; True if A is any vector or scalar data object. [P x] (defun math-objvecp (a) ; [Public] X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float cplx polar X hms date sdev intv mod vec incomplete))) ) X ;;; True if A is an object not composed of sub-formulas . [P x] [Public] (defun math-primp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float cplx polar X hms date mod var))) ) X ;;; True if A is numerically (but not literally) an integer. [P x] [Public] (defun math-messy-integerp (a) X (cond X ((eq (car-safe a) 'float) (>= (nth 2 a) 0)) X ((eq (car-safe a) 'frac) (Math-integerp (math-normalize a)))) ) X ;;; True if A is numerically an integer. [P x] [Public] (defun math-num-integerp (a) X (or (Math-integerp a) X (Math-messy-integerp a)) ) X ;;; True if A is (numerically) a non-negative integer. [P N] [Public] (defun math-num-natnump (a) X (or (natnump a) X (eq (car-safe a) 'bigpos) X (and (eq (car-safe a) 'float) X (Math-natnump (nth 1 a)) X (>= (nth 2 a) 0))) ) X ;;; True if A is an integer or will evaluate to an integer. [P x] [Public] (defun math-provably-integerp (a) X (or (Math-integerp a) X (and (memq (car-safe a) '(calcFunc-trunc X calcFunc-round X calcFunc-rounde X calcFunc-roundu X calcFunc-floor X calcFunc-ceil)) X (= (length a) 2))) ) X ;;; True if A is a real or will evaluate to a real. [P x] [Public] (defun math-provably-realp (a) X (or (Math-realp a) X (math-provably-integer a) X (memq (car-safe a) '(abs arg))) ) X ;;; True if A is a non-real, complex number. [P x] [Public] (defun math-complexp (a) X (memq (car-safe a) '(cplx polar)) ) X ;;; True if A is a non-real, rectangular complex number. [P x] [Public] (defun math-rect-complexp (a) X (eq (car-safe a) 'cplx) ) X ;;; True if A is a non-real, polar complex number. [P x] [Public] (defun math-polar-complexp (a) X (eq (car-safe a) 'polar) ) X ;;; True if A is a matrix. [P x] [Public] (defun math-matrixp (a) X (and (Math-vectorp a) X (Math-vectorp (nth 1 a)) X (cdr (nth 1 a)) X (math-matrixp-step (cdr (cdr a)) (length (nth 1 a)))) ) X (defun math-matrixp-step (a len) ; [P L] X (or (null a) X (and (Math-vectorp (car a)) X (= (length (car a)) len) X (math-matrixp-step (cdr a) len))) ) X ;;; True if A is a square matrix. [P V] [Public] (defun math-square-matrixp (a) X (let ((dims (math-mat-dimens a))) X (and (cdr dims) X (= (car dims) (nth 1 dims)))) ) X ;;; True if A is any scalar data object. [P x] (defun math-objectp (a) ; [Public] X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float cplx X polar hms date sdev intv mod))) ) X ;;; Verify that A is an integer and return A in integer form. [I N; - x] (defun math-check-integer (a) ; [Public] X (cond ((integerp a) a) ; for speed X ((math-integerp a) a) X ((math-messy-integerp a) X (math-trunc a)) X (t (math-reject-arg a 'integerp))) ) X ;;; Verify that A is a small integer and return A in integer form. [S N; - x] (defun math-check-fixnum (a &optional allow-inf) ; [Public] X (cond ((integerp a) a) ; for speed X ((Math-num-integerp a) X (let ((a (math-trunc a))) X (if (integerp a) X a X (if (or (Math-lessp (lsh -1 -1) a) X (Math-lessp a (- (lsh -1 -1)))) X (math-reject-arg a 'fixnump) X (math-fixnum a))))) X ((and allow-inf (equal a '(var inf var-inf))) X (lsh -1 -1)) X ((and allow-inf (equal a '(neg (var inf var-inf)))) X (- (lsh -1 -1))) X (t (math-reject-arg a 'fixnump))) ) X ;;; Verify that A is an integer >= 0 and return A in integer form. [I N; - x] (defun math-check-natnum (a) ; [Public] X (cond ((natnump a) a) X ((and (not (math-negp a)) X (Math-num-integerp a)) X (math-trunc a)) X (t (math-reject-arg a 'natnump))) ) X ;;; Verify that A is in floating-point form, or force it to be a float. [F N] (defun math-check-float (a) ; [Public] X (cond ((eq (car-safe a) 'float) a) X ((Math-vectorp a) (math-map-vec 'math-check-float a)) X ((Math-objectp a) (math-float a)) X (t a)) ) X ;;; Verify that A is a constant. (defun math-check-const (a &optional exp-ok) X (if (or (math-constp a) X (and exp-ok math-expand-formulas)) X a X (math-reject-arg a 'constp)) ) X X ;;; Coerce integer A to be a small integer. [S I] (defun math-fixnum (a) X (if (consp a) X (if (cdr a) X (if (eq (car a) 'bigneg) X (- (math-fixnum-big (cdr a))) X (math-fixnum-big (cdr a))) X 0) X a) ) X (defun math-fixnum-big (a) X (if (cdr a) X (+ (car a) (* (math-fixnum-big (cdr a)) 1000)) X (car a)) ) X X (defun math-normalize-fancy (a) X (cond ((eq (car a) 'frac) X (math-make-frac (math-normalize (nth 1 a)) X (math-normalize (nth 2 a)))) X ((eq (car a) 'cplx) X (let ((real (math-normalize (nth 1 a))) X (imag (math-normalize (nth 2 a)))) X (if (and (math-zerop imag) X (not math-simplify-only)) ; oh, what a kludge! X real X (list 'cplx real imag)))) X ((eq (car a) 'polar) X (math-normalize-polar a)) X ((eq (car a) 'hms) X (math-normalize-hms a)) X ((eq (car a) 'date) X (list 'date (math-normalize (nth 1 a)))) X ((eq (car a) 'mod) X (math-normalize-mod a)) X ((eq (car a) 'sdev) X (let ((x (math-normalize (nth 1 a))) X (s (math-normalize (nth 2 a)))) X (if (or (and (Math-objectp x) (not (Math-scalarp x))) X (and (Math-objectp s) (not (Math-scalarp s)))) X (list 'calcFunc-sdev x s) X (math-make-sdev x s)))) X ((eq (car a) 'intv) X (let ((mask (math-normalize (nth 1 a))) X (lo (math-normalize (nth 2 a))) X (hi (math-normalize (nth 3 a)))) X (if (if (eq (car-safe lo) 'date) X (not (eq (car-safe hi) 'date)) X (or (and (Math-objectp lo) (not (Math-anglep lo))) X (and (Math-objectp hi) (not (Math-anglep hi))))) X (list 'calcFunc-intv mask lo hi) X (math-make-intv mask lo hi)))) X ((eq (car a) 'vec) X (cons 'vec (mapcar 'math-normalize (cdr a)))) X ((eq (car a) 'quote) X (math-normalize (nth 1 a))) X ((eq (car a) 'special-const) X (calc-with-default-simplification X (math-normalize (nth 1 a)))) X ((eq (car a) 'var) X (cons 'var (cdr a))) ; need to re-cons for selection routines X ((eq (car a) 'calcFunc-if) X (math-normalize-logical-op a)) X ((memq (car a) '(calcFunc-lambda calcFunc-quote calcFunc-condition)) X (let ((calc-simplify-mode 'none)) X (cons (car a) (mapcar 'math-normalize (cdr a))))) X ((eq (car a) 'calcFunc-evalto) X (setq a (or (nth 1 a) 0)) X (or calc-refreshing-evaltos X (setq a (let ((calc-simplify-mode 'none)) (math-normalize a)))) X (let ((b (if (and (eq (car-safe a) 'calcFunc-assign) X (= (length a) 3)) X (nth 2 a) X a))) X (list 'calcFunc-evalto X a X (if (eq calc-simplify-mode 'none) X (math-normalize b) X (calc-with-default-simplification X (math-evaluate-expr b)))))) X ((or (integerp (car a)) (consp (car a))) X (if (null (cdr a)) X (math-normalize (car a)) X (error "Can't use multi-valued function in an expression")))) ) X (defun math-normalize-nonstandard () ; uses "a" X (if (consp calc-simplify-mode) X (progn X (setq calc-simplify-mode 'none X math-simplify-only (car-safe (cdr-safe a))) X nil) X (and (symbolp (car a)) X (or (eq calc-simplify-mode 'none) X (and (eq calc-simplify-mode 'num) X (let ((aptr (setq a (cons X (car a) X (mapcar 'math-normalize (cdr a)))))) X (while (and aptr (math-constp (car aptr))) X (setq aptr (cdr aptr))) X aptr))) X (cons (car a) (mapcar 'math-normalize (cdr a))))) ) X X X (setq math-expand-formulas nil) X X ;;; Normalize a bignum digit list by trimming high-end zeros. [L l] (defun math-norm-bignum (a) X (let ((digs a) (last nil)) X (while digs X (or (eq (car digs) 0) (setq last digs)) X (setq digs (cdr digs))) X (and last X (progn X (setcdr last nil) X a))) ) X (defun math-bignum-test (a) ; [B N; B s; b b] X (if (consp a) X a X (math-bignum a)) ) X X ;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public] (defun calcFunc-sign (a &optional x) X (let ((signs (math-possible-signs a))) X (cond ((eq signs 4) (or x 1)) X ((eq signs 2) 0) X ((eq signs 1) (if x (math-neg x) -1)) X ((math-looks-negp a) (math-neg (calcFunc-sign (math-neg a)))) X (t (calc-record-why 'realp a) X (if x X (list 'calcFunc-sign a x) X (list 'calcFunc-sign a))))) ) X ;;; Return 0 if A is numerically equal to B, <0 if less, >0 if more. ;;; Arguments must be normalized! [S N N] (defun math-compare (a b) X (cond ((equal a b) X (if (and (consp a) X (memq (car a) '(var neg * /)) X (math-infinitep a)) X 2 X 0)) X ((and (integerp a) (Math-integerp b)) X (if (consp b) X (if (eq (car b) 'bigpos) -1 1) X (if (< a b) -1 1))) X ((and (eq (car-safe a) 'bigpos) (Math-integerp b)) X (if (eq (car-safe b) 'bigpos) X (math-compare-bignum (cdr a) (cdr b)) X 1)) X ((and (eq (car-safe a) 'bigneg) (Math-integerp b)) X (if (eq (car-safe b) 'bigneg) X (math-compare-bignum (cdr b) (cdr a)) X -1)) X ((eq (car-safe a) 'frac) X (if (eq (car-safe b) 'frac) X (math-compare (math-mul (nth 1 a) (nth 2 b)) X (math-mul (nth 1 b) (nth 2 a))) X (math-compare (nth 1 a) (math-mul b (nth 2 a))))) X ((eq (car-safe b) 'frac) X (math-compare (math-mul a (nth 2 b)) (nth 1 b))) X ((and (eq (car-safe a) 'float) (eq (car-safe b) 'float)) X (if (math-lessp-float a b) -1 1)) X ((and (eq (car-safe a) 'date) (eq (car-safe b) 'date)) X (math-compare (nth 1 a) (nth 1 b))) X ((and (or (Math-anglep a) X (and (eq (car a) 'cplx) (eq (nth 2 a) 0))) X (or (Math-anglep b) X (and (eq (car b) 'cplx) (eq (nth 2 b) 0)))) X (calcFunc-sign (math-add a (math-neg b)))) X ((and (eq (car-safe a) 'intv) X (or (Math-anglep b) (eq (car-safe b) 'date))) X (let ((res (math-compare (nth 2 a) b))) X (cond ((eq res 1) 1) X ((and (eq res 0) (memq (nth 1 a) '(0 1))) 1) X ((eq (setq res (math-compare (nth 3 a) b)) -1) -1) X ((and (eq res 0) (memq (nth 1 a) '(0 2))) -1) X (t 2)))) X ((and (eq (car-safe b) 'intv) X (or (Math-anglep a) (eq (car-safe a) 'date))) X (let ((res (math-compare a (nth 2 b)))) X (cond ((eq res -1) -1) X ((and (eq res 0) (memq (nth 1 b) '(0 1))) -1) X ((eq (setq res (math-compare a (nth 3 b))) 1) 1) X ((and (eq res 0) (memq (nth 1 b) '(0 2))) 1) X (t 2)))) X ((and (eq (car-safe a) 'intv) (eq (car-safe b) 'intv)) X (let ((res (math-compare (nth 3 a) (nth 2 b)))) X (cond ((eq res -1) -1) X ((and (eq res 0) (or (memq (nth 1 a) '(0 2)) X (memq (nth 1 b) '(0 1)))) -1) X ((eq (setq res (math-compare (nth 2 a) (nth 3 b))) 1) 1) X ((and (eq res 0) (or (memq (nth 1 a) '(0 1)) X (memq (nth 1 b) '(0 2)))) 1) X (t 2)))) X ((math-infinitep a) X (if (or (equal a '(var uinf var-uinf)) X (equal a '(var nan var-nan))) X 2 X (let ((dira (math-infinite-dir a))) X (if (math-infinitep b) X (if (or (equal b '(var uinf var-uinf)) X (equal b '(var nan var-nan))) X 2 X (let ((dirb (math-infinite-dir b))) X (cond ((and (eq dira 1) (eq dirb -1)) 1) X ((and (eq dira -1) (eq dirb 1)) -1) X (t 2)))) X (cond ((eq dira 1) 1) X ((eq dira -1) -1) X (t 2)))))) X ((math-infinitep b) X (if (or (equal b '(var uinf var-uinf)) X (equal b '(var nan var-nan))) X 2 X (let ((dirb (math-infinite-dir b))) X (cond ((eq dirb 1) -1) X ((eq dirb -1) 1) X (t 2))))) X ((and (eq (car-safe a) 'calcFunc-exp) X (eq (car-safe b) '^) X (equal (nth 1 b) '(var e var-e))) X (math-compare (nth 1 a) (nth 2 b))) X ((and (eq (car-safe b) 'calcFunc-exp) X (eq (car-safe a) '^) X (equal (nth 1 a) '(var e var-e))) X (math-compare (nth 2 a) (nth 1 b))) X ((or (and (eq (car-safe a) 'calcFunc-sqrt) X (eq (car-safe b) '^) X (or (equal (nth 2 b) '(frac 1 2)) X (equal (nth 2 b) '(float 5 -1)))) X (and (eq (car-safe b) 'calcFunc-sqrt) X (eq (car-safe a) '^) X (or (equal (nth 2 a) '(frac 1 2)) X (equal (nth 2 a) '(float 5 -1))))) X (math-compare (nth 1 a) (nth 1 b))) X ((eq (car-safe a) 'var) X 2) X (t X (if (and (consp a) (consp b) X (eq (car a) (car b)) X (math-compare-lists (cdr a) (cdr b))) X 0 X 2))) ) X ;;; Compare two bignum digit lists, return -1 for A<B, 0 for A=B, 1 for A>B. (defun math-compare-bignum (a b) ; [S l l] X (let ((res 0)) X (while (and a b) X (if (< (car a) (car b)) X (setq res -1) X (if (> (car a) (car b)) X (setq res 1))) X (setq a (cdr a) X b (cdr b))) X (if a X (progn X (while (eq (car a) 0) (setq a (cdr a))) X (if a 1 res)) X (while (eq (car b) 0) (setq b (cdr b))) X (if b -1 res))) ) X (defun math-compare-lists (a b) X (cond ((null a) (null b)) X ((null b) nil) X (t (and (Math-equal (car a) (car b)) X (math-compare-lists (cdr a) (cdr b))))) ) X (defun math-lessp-float (a b) ; [P F F] X (let ((ediff (- (nth 2 a) (nth 2 b)))) X (if (>= ediff 0) X (if (>= ediff (+ calc-internal-prec calc-internal-prec)) X (if (eq (nth 1 a) 0) X (Math-integer-posp (nth 1 b)) X (Math-integer-negp (nth 1 a))) X (Math-lessp (math-scale-int (nth 1 a) ediff) X (nth 1 b))) X (if (>= (setq ediff (- ediff)) X (+ calc-internal-prec calc-internal-prec)) X (if (eq (nth 1 b) 0) X (Math-integer-negp (nth 1 a)) X (Math-integer-posp (nth 1 b))) X (Math-lessp (nth 1 a) X (math-scale-int (nth 1 b) ediff))))) ) X ;;; True if A is numerically equal to B. [P N N] [Public] (defun math-equal (a b) X (= (math-compare a b) 0) ) X ;;; True if A is numerically less than B. [P R R] [Public] (defun math-lessp (a b) X (= (math-compare a b) -1) ) X ;;; True if A is numerically equal to the integer B. [P N S] [Public] ;;; B must not be a multiple of 10. (defun math-equal-int (a b) X (or (eq a b) X (and (eq (car-safe a) 'float) X (eq (nth 1 a) b) X (= (nth 2 a) 0))) ) X X X X ;;; Return the dimensions of a matrix as a list. [l x] [Public] (defun math-mat-dimens (m) X (if (math-vectorp m) X (if (math-matrixp m) X (cons (1- (length m)) X (math-mat-dimens (nth 1 m))) X (list (1- (length m)))) X nil) ) X X X (defun calc-binary-op-fancy (name func arg ident unary) X (let ((n (prefix-numeric-value arg))) X (cond ((> n 1) X (calc-enter-result n X name X (list 'calcFunc-reduce X (math-calcFunc-to-var func) X (cons 'vec (calc-top-list-n n))))) X ((= n 1) X (if unary X (calc-enter-result 1 name (list unary (calc-top-n 1))))) X ((= n 0) X (if ident X (calc-enter-result 0 name ident) X (error "Argument must be nonzero"))) X (t X (let ((rhs (calc-top-n 1))) X (calc-enter-result (- 1 n) X name X (mapcar (function X (lambda (x) X (list func x rhs))) X (calc-top-list-n (- n) 2))))))) ) X (defun calc-unary-op-fancy (name func arg) X (let ((n (prefix-numeric-value arg))) X (if (= n 0) (setq n (calc-stack-size))) X (cond ((> n 0) X (calc-enter-result n X name X (mapcar (function X (lambda (x) X (list func x))) X (calc-top-list-n n)))) X ((< n 0) X (calc-enter-result 1 X name X (list func (calc-top-n (- n))) X (- n))))) ) X X X (defvar var-Decls (list 'vec)) X X X (setq math-simplify-only nil) X (defun math-inexact-result () X (and calc-symbolic-mode X (signal 'inexact-result nil)) ) X (defun math-overflow (&optional exp) X (if (and exp (math-negp exp)) X (math-underflow) X (signal 'math-overflow nil)) ) X (defun math-underflow () X (signal 'math-underflow nil) ) X X X ;;; Compute the greatest common divisor of A and B. [I I I] [Public] (defun math-gcd (a b) X (cond ((not (or (consp a) (consp b))) X (if (< a 0) (setq a (- a))) X (if (< b 0) (setq b (- b))) X (let (c) X (if (< a b) X (setq c b b a a c)) X (while (> b 0) X (setq c b X b (% a b) X a c)) X a)) X ((eq a 0) b) X ((eq b 0) a) X (t X (if (Math-integer-negp a) (setq a (math-neg a))) X (if (Math-integer-negp b) (setq b (math-neg b))) X (let (c) X (if (Math-natnum-lessp a b) X (setq c b b a a c)) X (while (and (consp a) (not (eq b 0))) X (setq c b X b (math-imod a b) X a c)) X (while (> b 0) X (setq c b X b (% a b) X a c)) X a))) ) X X ;;;; Algebra. X ;;; Evaluate variables in an expression. (defun math-evaluate-expr (x) ; [Public] X (if calc-embedded-info X (calc-embedded-evaluate-expr x) X (calc-normalize (math-evaluate-expr-rec x))) ) (fset 'calcFunc-evalv (symbol-function 'math-evaluate-expr)) X (defun calcFunc-evalvn (x &optional prec) X (if prec X (progn X (or (math-num-integerp prec) X (if (and (math-vectorp prec) X (= (length prec) 2) X (math-num-integerp (nth 1 prec))) X (setq prec (math-add (nth 1 prec) calc-internal-prec)) X (math-reject-arg prec 'integerp))) X (setq prec (math-trunc prec)) X (if (< prec 3) (setq prec 3)) X (if (> prec calc-internal-prec) X (math-normalize X (let ((calc-internal-prec prec)) X (calcFunc-evalvn x))) X (let ((calc-internal-prec prec)) X (calcFunc-evalvn x)))) X (let ((calc-symbolic-mode nil)) X (math-evaluate-expr x))) ) X (defun math-evaluate-expr-rec (x) X (if (consp x) X (if (memq (car x) '(calcFunc-quote calcFunc-condition X calcFunc-evalto calcFunc-assign)) X (if (and (eq (car x) 'calcFunc-assign) X (= (length x) 3)) X (list (car x) (nth 1 x) (math-evaluate-expr-rec (nth 2 x))) X x) X (if (eq (car x) 'var) X (if (and (calc-var-value (nth 2 x)) X (not (eq (car-safe (symbol-value (nth 2 x))) X 'incomplete))) X (let ((val (symbol-value (nth 2 x)))) X (if (eq (car-safe val) 'special-const) X (if calc-symbolic-mode X x X val) X val)) X x) X (if (Math-primp x) X x X (cons (car x) (mapcar 'math-evaluate-expr-rec (cdr x)))))) X x) ) X X X (setq math-simplifying nil) (setq math-living-dangerously nil) ; true if unsafe simplifications are okay. (setq math-integrating nil) X X X X (defmacro math-defsimplify (funcs &rest code) X (append '(progn (math-need-std-simps)) X (mapcar (function X (lambda (func) X (list 'put (list 'quote func) ''math-simplify X (list 'nconc X (list 'get (list 'quote func) ''math-simplify) X (list 'list X (list 'function X (append '(lambda (expr)) X code))))))) X (if (symbolp funcs) (list funcs) funcs))) ) (put 'math-defsimplify 'lisp-indent-hook 1) X X (defun math-any-floats (expr) X (if (Math-primp expr) X (math-floatp expr) X (while (and (setq expr (cdr expr)) (not (math-any-floats (car expr))))) X expr) ) X (defvar var-FactorRules 'calc-FactorRules) X X X (defun math-map-tree (mmt-func mmt-expr &optional mmt-many) X (or mmt-many (setq mmt-many 1000000)) X (math-map-tree-rec mmt-expr) ) X (defun math-map-tree-rec (mmt-expr) X (or (= mmt-many 0) X (let ((mmt-done nil) X mmt-nextval) X (while (not mmt-done) X (while (and (/= mmt-many 0) X (setq mmt-nextval (funcall mmt-func mmt-expr)) X (not (equal mmt-expr mmt-nextval))) X (setq mmt-expr mmt-nextval X mmt-many (if (> mmt-many 0) (1- mmt-many) (1+ mmt-many)))) X (if (or (Math-primp mmt-expr) X (<= mmt-many 0)) X (setq mmt-done t) X (setq mmt-nextval (cons (car mmt-expr) X (mapcar 'math-map-tree-rec X (cdr mmt-expr)))) X (if (equal mmt-nextval mmt-expr) X (setq mmt-done t) X (setq mmt-expr mmt-nextval)))))) X mmt-expr ) X X X X (setq math-rewrite-selections nil) X (defun math-is-true (expr) X (if (Math-numberp expr) X (not (Math-zerop expr)) X (math-known-nonzerop expr)) ) X (defun math-const-var (expr) X (and (consp expr) X (eq (car expr) 'var) X (or (and (symbolp (nth 2 expr)) X (boundp (nth 2 expr)) X (eq (car-safe (symbol-value (nth 2 expr))) 'special-const)) X (memq (nth 2 expr) '(var-inf var-uinf var-nan)))) ) X X X X (defmacro math-defintegral (funcs &rest code) X (setq math-integral-cache nil) X (append '(progn) X (mapcar (function X (lambda (func) X (list 'put (list 'quote func) ''math-integral X (list 'nconc X (list 'get (list 'quote func) ''math-integral) X (list 'list X (list 'function X (append '(lambda (u)) X code))))))) X (if (symbolp funcs) (list funcs) funcs))) ) (put 'math-defintegral 'lisp-indent-hook 1) X (defmacro math-defintegral-2 (funcs &rest code) X (setq math-integral-cache nil) X (append '(progn) X (mapcar (function X (lambda (func) X (list 'put (list 'quote func) ''math-integral-2 X (list 'nconc X (list 'get (list 'quote func) X ''math-integral-2) X (list 'list X (list 'function X (append '(lambda (u v)) X code))))))) X (if (symbolp funcs) (list funcs) funcs))) ) (put 'math-defintegral-2 'lisp-indent-hook 1) X X (defvar var-IntegAfterRules 'calc-IntegAfterRules) X X (defvar var-FitRules 'calc-FitRules) X X (setq math-poly-base-variable nil) (setq math-poly-neg-powers nil) (setq math-poly-mult-powers 1) (setq math-poly-frac-powers nil) (setq math-poly-exp-base nil) X X X X (defun math-build-var-name (name) X (if (stringp name) X (setq name (intern name))) X (if (string-match "\\`var-." (symbol-name name)) X (list 'var (intern (substring (symbol-name name) 4)) name) X (list 'var name (intern (concat "var-" (symbol-name name))))) ) X (setq math-simplifying-units nil) (setq math-combining-units t) X X (put 'math-while 'lisp-indent-hook 1) (put 'math-for 'lisp-indent-hook 1) (put 'math-foreach 'lisp-indent-hook 1) X X ;;; Nontrivial number parsing. X (defun math-read-number-fancy (s) X (cond X X ;; Integer+fractions X ((string-match "^\$[0-9]*\$[:/]\$[0-9]*\$[:/]\$[0-9]*\$$" s) X (let ((int (math-match-substring s 1)) X (num (math-match-substring s 2)) X (den (math-match-substring s 3))) X (let ((int (if (> (length int) 0) (math-read-number int) 0)) X (num (if (> (length num) 0) (math-read-number num) 1)) X (den (if (> (length num) 0) (math-read-number den) 1))) X (and int num den X (math-integerp int) (math-integerp num) (math-integerp den) X (not (math-zerop den)) X (list 'frac (math-add num (math-mul int den)) den))))) X X ;; Fractions X ((string-match "^\$[0-9]*\$[:/]\$[0-9]*\$$" s) X (let ((num (math-match-substring s 1)) X (den (math-match-substring s 2))) X (let ((num (if (> (length num) 0) (math-read-number num) 1)) X (den (if (> (length num) 0) (math-read-number den) 1))) X (and num den (math-integerp num) (math-integerp den) X (not (math-zerop den)) X (list 'frac num den))))) X X ;; Modulo forms X ((string-match "^\$.*\$ *mod *\$.*\$$" s) X (let* ((n (math-match-substring s 1)) X (m (math-match-substring s 2)) X (n (math-read-number n)) X (m (math-read-number m))) X (and n m (math-anglep n) (math-anglep m) X (list 'mod n m)))) X X ;; Error forms X ((string-match "^\$.*\$ *\\+/- *\$.*\$$" s) X (let* ((x (math-match-substring s 1)) X (sigma (math-match-substring s 2)) X (x (math-read-number x)) X (sigma (math-read-number sigma))) X (and x sigma (math-scalarp x) (math-anglep sigma) X (list 'sdev x sigma)))) X X ;; Hours (or degrees) X ((or (string-match "^\$[^#^]+\$[@oOhH]\$.*\$$" s) X (string-match "^\$[^#^]+\$[dD][eE]?[gG]?\$.*\$$" s)) X (let* ((hours (math-match-substring s 1)) X (minsec (math-match-substring s 2)) X (hours (math-read-number hours)) X (minsec (if (> (length minsec) 0) (math-read-number minsec) 0))) X (and hours minsec X (math-num-integerp hours) X (not (math-negp hours)) (not (math-negp minsec)) X (cond ((math-num-integerp minsec) X (and (Math-lessp minsec 60) X (list 'hms hours minsec 0))) X ((and (eq (car-safe minsec) 'hms) X (math-zerop (nth 1 minsec))) X (math-add (list 'hms hours 0 0) minsec)) X (t nil))))) X X ;; Minutes X ((string-match "^\$[^'#^]+\$[mM']\$.*\$$" s) X (let* ((minutes (math-match-substring s 1)) X (seconds (math-match-substring s 2)) X (minutes (math-read-number minutes)) X (seconds (if (> (length seconds) 0) (math-read-number seconds) 0))) X (and minutes seconds X (math-num-integerp minutes) X (not (math-negp minutes)) (not (math-negp seconds)) X (cond ((math-realp seconds) X (and (Math-lessp minutes 60) X (list 'hms 0 minutes seconds))) X ((and (eq (car-safe seconds) 'hms) X (math-zerop (nth 1 seconds)) X (math-zerop (nth 2 seconds))) X (math-add (list 'hms 0 minutes 0) seconds)) X (t nil))))) X X ;; Seconds X ((string-match "^\$[^\"#^]+\$[sS\"]$" s) X (let ((seconds (math-read-number (math-match-substring s 1)))) X (and seconds (math-realp seconds) X (not (math-negp seconds)) X (Math-lessp seconds 60) X (list 'hms 0 0 seconds)))) X X ;; Integer+fraction with explicit radix X ((string-match "^\$[0-9]+\$\$#\\|\\^\\^\$\$[0-9a-zA-Z]*\$[:/]\$[0-9a-zA-Z]*\$[:/]\$[0-9a-zA-Z]\$$" s) X (let ((radix (string-to-int (math-match-substring s 1))) X (int (math-match-substring s 3)) X (num (math-match-substring s 4)) X (den (math-match-substring s 5))) X (let ((int (if (> (length int) 0) (math-read-radix int radix) 0)) X (num (if (> (length num) 0) (math-read-radix num radix) 1)) X (den (if (> (length den) 0) (math-read-radix den radix) 1))) X (and int num den (not (math-zerop den)) X (list 'frac X (math-add num (math-mul int den)) X den))))) X X ;; Fraction with explicit radix X ((string-match "^\$[0-9]+\$\$#\\|\\^\\^\$\$[0-9a-zA-Z]*\$[:/]\$[0-9a-zA-Z]*\$$" s) X (let ((radix (string-to-int (math-match-substring s 1))) X (num (math-match-substring s 3)) X (den (math-match-substring s 4))) X (let ((num (if (> (length num) 0) (math-read-radix num radix) 1)) X (den (if (> (length den) 0) (math-read-radix den radix) 1))) X (and num den (not (math-zerop den)) (list 'frac num den))))) X X ;; Float with explicit radix and exponent X ((or (string-match "^0*\$\\([2-9]\\|1[0-4]\$\$#\\|\\^\\^\$[0-9a-dA-D.]+\\)[eE]\$[-+]?[0-9]+\$$" s) X (string-match "^\$\\([0-9]+\$\$#\\|\\^\\^\$[0-9a-zA-Z.]+\\) *\\* *\\2\\.? *\\^ *\$[-+]?[0-9]+\$$" s)) X (let ((radix (string-to-int (math-match-substring s 2))) X (mant (math-match-substring s 1)) X (exp (math-match-substring s 4))) X (let ((mant (math-read-number mant)) X (exp (math-read-number exp))) X (and mant exp X (math-mul mant (math-pow (math-float radix) exp)))))) X X ;; Float with explicit radix, no exponent X ((string-match "^\$[0-9]+\$\$#\\|\\^\\^\$\$[0-9a-zA-Z]*\$\\.\$[0-9a-zA-Z]*\$$" s) X (let ((radix (string-to-int (math-match-substring s 1))) X (int (math-match-substring s 3)) X (fracs (math-match-substring s 4))) X (let ((int (if (> (length int) 0) (math-read-radix int radix) 0)) X (frac (if (> (length fracs) 0) (math-read-radix fracs radix) 0)) X (calc-prefer-frac nil)) X (and int frac X (math-add int (math-div frac (math-pow radix (length fracs)))))))) X X ;; Integer with explicit radix X ((string-match "^\$[0-9]+\$\$#\\|\\^\\^\$\$[0-9a-zA-Z]+\$$" s) X (math-read-radix (math-match-substring s 3) X (string-to-int (math-match-substring s 1)))) X X ;; C language hexadecimal notation X ((and (eq calc-language 'c) X (string-match "^0[xX]\$[0-9a-fA-F]+\$$" s)) X (let ((digs (math-match-substring s 1))) X (math-read-radix digs 16))) X X ;; Pascal language hexadecimal notation X ((and (eq calc-language 'pascal) X (string-match "^\\$\$[0-9a-fA-F]+\$$" s)) X (let ((digs (math-match-substring s 1))) X (math-read-radix digs 16))) X X ;; Fraction using "/" instead of ":" X ((string-match "^\$[0-9]+\$/\$[0-9/]+\$$" s) X (math-read-number (concat (math-match-substring s 1) ":" X (math-match-substring s 2)))) X X ;; Syntax error! X (t nil)) ) X (defun math-read-radix (s r) ; [I X D] X (catch 'gonzo X (math-read-radix-loop (upcase s) (1- (length s)) r)) ) X (defun math-read-radix-loop (s i r) ; [I X S D] X (if (< i 0) X 0 X (let ((dig (math-read-radix-digit (elt s i)))) X (if (and dig (< dig r)) X (math-add (math-mul (math-read-radix-loop s (1- i) r) X r) X dig) X (throw 'gonzo nil)))) ) X X X ;;; Expression parsing. X (defun math-read-expr (exp-str) X (let ((exp-pos 0) X (exp-old-pos 0) X (exp-keep-spaces nil) X exp-token exp-data) X (while (setq exp-token (string-match "\\.\\." exp-str)) X (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots" X (substring exp-str (+ exp-token 2))))) X (math-read-token) X (let ((val (catch 'syntax (math-read-expr-level 0)))) X (if (stringp val) X (list 'error exp-old-pos val) X (if (equal exp-token 'end) X val X (list 'error exp-old-pos "Syntax error"))))) ) X (defun math-read-plain-expr (exp-str &optional error-check) SHAR_EOF true || echo 'restore of calc-ext.el failed' fi echo 'End of part 14' echo 'File calc-ext.el is continued in part 15' echo 15 > _shar_seq_.tmp exit 0 exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.